home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / VTOOLS / VTLIST.PAS < prev    next >
Pascal/Delphi Source File  |  1995-03-11  |  20KB  |  472 lines
  1. UNIT VTLIST;
  2. INTERFACE
  3. Uses VTFast,VTKey,VTWin,Crt;
  4.  
  5.  Const MaxLines = 255;
  6.        MaxLists = 5;
  7.  
  8.  Type ShortString = String[77];
  9.  Type ListType = ShortString;
  10.  Type Choices = array[1..MaxLines] Of Boolean; { Array that idicates selected topics }
  11.  Type ListHook = Procedure(Ch : Byte; Var Refresh :  Boolean; ToPick : Byte);
  12.                  { Type of procedure that calls each time when key is pressed}
  13.                  { Ch - Position code of pressed key | Refresh - if true
  14.                                                        viseble topics will
  15.                                                        redisplayed
  16.                    Topic is a current hilighted topic }
  17.  Type ListSet = Set of Byte;
  18.  Type ListDescription = Record  { Description of every listtable }
  19.                                 X,Y : Byte;    { TopLeft side of Box }
  20.                               Lines : Byte;    { Showed Lines }
  21.                              SWidth : Byte;    { Width of selector }
  22.                            EscValid : Boolean; { Is escape valid ? /True - Valid }
  23.                                BoxT : Byte;    { Type of Box }
  24.                                Beep,           { Beep on invalid key ? }
  25.                              Shadow,           { Shadow ? }
  26.                             Explode : Boolean; { Explode the box ?}
  27.                               BoxF,            { Box Foreground & BackGroun }
  28.                               BoxB,
  29.                             InnerF,            { Box Inner foreground & backGround }
  30.                              InnerB : Byte;    { Normal Topics are too }
  31.                         SelTopicF,            { Selected Topic Foreground }
  32.                          SelTopicB : Byte;    { &BackGround }
  33.                      Only1Selection : Boolean; { Can user select 1 topic }
  34.                             SelChar : Byte;    { Indicator for selected topics}
  35.                            EndChars : ListSet; { PosCode of Keys for finish }
  36.                            SelChars : ListSet; { PosCode of Keys for select }
  37.                      ResetSelection : Boolean; { Clear selection before
  38.                                                      displaying }
  39.                               Title : ShortString;
  40.                           TitF,TitB : Byte;
  41.                            SavedScr : Pointer;
  42.                           Selection : Choices;   { Section flags }
  43.                            CallHook : ListHook;  { Each time when key is pressed }
  44.                         End;                     { procedure has called }
  45. Var Lists : Array[1..MaxLists] of ^ListDescription; { Listtables }
  46.     RetLPChar : Byte; { Position code of last pressed key }
  47.     RetLAChar : Byte; { ASCII code of last pressed key }
  48.     LastHiTop : Byte; { Number of last selected Topic }
  49.    UserLHook : Pointer;
  50.  
  51. Procedure ListInit; { Initialize unit with start parameters. Not recomended
  52.                                             to use it with defined menus }
  53. Procedure DefaultSettings(ListNum : Byte); { Set a listtable with default }
  54. Procedure ClearSelection (ListNum : Byte); { Clears a selected topics }
  55. Procedure AttachList (ListNum : Byte);     {Reserve memory for listtable }
  56.                                            { to use it }
  57. Procedure DeAttachList(ListNum : Byte);    {Release reserved memory }
  58. Procedure DefineList(ListNum,Xp,Yp,Box_T,Box_F,Box_B,InF,InB,SelTF,SelTB,
  59.                      Tit_F,Tit_B : Byte;Tit : ShortString);
  60.  { Defines a list coordinates,colors & etc. }
  61. Procedure SetList(ListNum,Ln,Sw,Sc : Byte; EV,Sh,Ex,O1S,RS,Bp : Boolean);
  62.  { Defines list rules }
  63. Procedure SetHook(ListNum : Byte; CallP : ListHook); { Defines a called procedure }
  64. Procedure SetSelection(ListNum : Byte; Sel : Choices); {Defines a selection of listtable }
  65. Procedure SetEndChars(ListNum : Byte; EndC : ListSet); {Defines a Position
  66.                                          codes of keys for exit from list }
  67. Procedure SetSelectChars(ListNum : Byte; SelC : ListSet);{Defines a Position
  68.                                          codes of keys for select from list }
  69. Procedure ResetList(Var UserList); { Fill the list with ASCII char '0' }
  70. Procedure DisplayList(ListTable,ListLines : Byte; Var UserList);
  71. { Displays the list of user. UserLines must be of ListType !
  72.                              ListLines MUST be size of array
  73.                              ListTable is a rules to display list }
  74.  
  75. IMPLEMENTATION
  76.  Type ListInfo = Record
  77.                   Attached : Boolean;
  78.                  Displayed : Boolean;
  79.                  End;
  80.  
  81. Var Tmp : Byte;
  82.     Akey,PKey : Byte;
  83.     LInfo : Array[1..MaxLists] of ListInfo;
  84.  
  85. Procedure VTListError(ErrC : Byte);
  86. Var Msg : ShortString;
  87. Begin
  88.  Write('VTList ERROR #',ErrC);
  89.  Case ErrC Of
  90.        1 : Msg := '. List MUST be attached first to use.';
  91.        2 : Msg := '. Request to reattach list.List allready attached.';
  92.        3 : Msg := '. Request to redisplay list.List allready displayed.';
  93.        4 : Msg := '. Not enought memory for operation!';
  94.        5 : Msg := '. Request to Dispose list. List not attached.';
  95.        6 : Msg := '. Request to change list parameters! List is displayed.';
  96.        7 : Msg := '. User (input) array is too large!';
  97.  End;
  98.  
  99.  WriteLn(Msg);
  100.  Halt;
  101. End;
  102.  
  103. Procedure DefaultSettings(ListNum : Byte);
  104.  Var Tmp1 : Byte;
  105. Begin
  106.  If Not LInfo[ListNum].Attached Then VTListError(1);
  107.  Lists[ListNum]^.CallHook := Nil;
  108.  DefineList(ListNum,0,6,1,15,1,14,1,15,red,lightgreen,1,'');
  109.  SetList(ListNum,10,0,251,True,True,False,False,True,True);
  110.  SetEndChars(ListNum,[28]);
  111.  SetSelectChars(ListNum,[57]);
  112.  ClearSelection (ListNum);
  113. End;
  114. Procedure ClearSelection(ListNum : Byte);
  115. Var I : Byte;
  116. Begin
  117.  If Not LInfo[ListNum].Attached Then VTListError(1);
  118.  For I := 1 To MaxLines Do Lists[ListNum]^.Selection[I] := False;
  119. End;
  120.  
  121. Procedure AttachList (ListNum : Byte);
  122. Begin
  123.  If MaxAvail < SizeOf(ListDescription) Then VTListError(4);
  124.  LInfo[ListNum].Attached := True;
  125.  GetMem(Lists[ListNum],SizeOf(ListDescription));
  126. End;
  127.  
  128. Procedure DeAttachList(ListNum : Byte);
  129. Begin
  130.  If Not LInfo[ListNum].Attached Then VTListError(5);
  131.  LInfo[ListNum].Attached := False;
  132.  FreeMem(Lists[ListNum],SizeOf(ListDescription));
  133. End;
  134.  
  135. Procedure DefineList(ListNum,Xp,Yp,Box_T,Box_F,Box_B,InF,InB,SelTF,SelTB,
  136.                      Tit_F,Tit_B : Byte;Tit : ShortString);
  137. Begin
  138.  If Not Linfo[ListNum].Attached Then VTListError(1);
  139.  If LInfo[ListNum] .Displayed Then VtListError(6);
  140.  With Lists[ListNum]^ Do Begin
  141.                           X := Xp; Y := Yp; BoxT := Box_T;
  142.                           BoxF := Box_F; BoxB := Box_B;
  143.                           InnerF := InF; InnerB := InB;
  144.                           SelTopicF := SelTF; SelTopicB := SelTB;
  145.                           TitF := Tit_F; TitB := Tit_B; Title := Tit;
  146.                          End;
  147. End;
  148.  
  149. Procedure SetList(ListNum,Ln,Sw,Sc : Byte; EV,Sh,Ex,O1S,RS,Bp : Boolean);
  150. Begin
  151.  If Not Linfo[ListNum].Attached Then VTListError(1);
  152.  If LInfo[ListNum] .Displayed Then VtListError(6);
  153.  With Lists[ListNum]^ Do Begin
  154.                           Lines := Ln; SWidth := Sw;
  155.                           SelChar := Sc; EscValid := EV;
  156.                           Shadow := Sh; Only1Selection := O1S;
  157.                           Explode := Ex;
  158.                           ResetSelection := RS; Beep := Bp;
  159.                          End;
  160.  
  161. End;
  162.  
  163. Procedure SetHook(ListNum : Byte; CallP : ListHook);
  164. Begin
  165.  If Not Linfo[ListNum].Attached Then VTListError(1);
  166.  Lists[ListNum]^.CallHook := CallP;
  167. End;
  168.  
  169. Procedure SetSelection(ListNum : Byte; Sel : Choices);
  170. Begin
  171.  If Not Linfo[ListNum].Attached Then VTListError(1);
  172.  If LInfo[ListNum] .Displayed Then VtListError(6);
  173.  Lists[ListNum]^.Selection :=Sel;
  174. End;
  175.  
  176. Procedure SetEndChars(ListNum : Byte; EndC : ListSet);
  177. Begin
  178.  If Not Linfo[ListNum].Attached Then VTListError(1);
  179.  If LInfo[ListNum] .Displayed Then VtListError(6);
  180.  Lists[ListNum]^.EndChars := EndC;
  181. End;
  182.  
  183. Procedure SetSelectChars(ListNum : Byte; SelC : ListSet);
  184. Begin
  185.  If Not Linfo[ListNum].Attached Then VTListError(1);
  186.  If LInfo[ListNum] .Displayed Then VtListError(6);
  187.  Lists[ListNum]^.SelChars := SelC;
  188. End;
  189. Procedure ResetList(Var UserList);
  190. Begin
  191.  FillChar(UserList,SizeOf(userList),#0);
  192. End;
  193.  
  194.  
  195. Procedure Clang;
  196. Begin
  197.  Sound(1000);
  198.  Delay(5);
  199.  Nosound;
  200.  Delay(1);
  201.  Sound(1500);
  202.  Delay(7);
  203.  NoSound;
  204. End;
  205.            {===================******===================}
  206. Procedure DisplayList(ListTable,ListLines : Byte; Var UserList);
  207. Var StartX,StartY, { Left Top Corner }
  208.     EndX,EndY,     { Right down corner }
  209.     UserLines,
  210.     DispLines,
  211.     DispWidth,
  212.       HiTopic,
  213.   PrevHiTopic,
  214.     StartP,EndP : Word;
  215.   CX,CY,CT,CB : Byte;
  216.  Function TopicToString(TopN : Byte) : String;  { INTERNAL }
  217.  { Converts a user topic to normal string }
  218.  Var TmpS : ShortString;
  219.  Begin
  220.   Move(Mem[Seg(UserList):Ofs(userList)+((TopN-1) * 78)],Mem[Seg(TmpS):Ofs(TmpS)],78);
  221.   TopicToString := TmpS;
  222.  End; {Topictostring}
  223.  Function GrabWidthFromUser : Byte; { Grab a maximal width topic }
  224.  Var Temp : Byte;
  225.      Temp1 : Byte;
  226.      UserL : Byte;
  227.  Begin
  228.    Temp1 := 0;
  229.    For Temp := 1 To ListLines Do
  230.        Begin
  231.        UserL := Length(TopicToString(Temp));
  232.        If  UserL > Temp1 Then Temp1 := UserL;
  233.        End;
  234.        GrabWidthFromUser := Temp1;
  235.  End; { GrabWidthFromUser }
  236.  
  237. Procedure SetParameters(LN : Byte); { Set parameters to display list }
  238. Begin
  239.  DispWidth := GrabWidthFromUser;
  240.  UserLines := ListLines;{GrabLinesFromUser};
  241.  With Lists[LN]^ Do
  242.  Begin
  243.   If X = 0 Then StartX := 37 - (DispWidth div 2)
  244.   Else StartX := X;
  245.   If UserLines < Lines Then DispLines := UserLines
  246.   Else DispLines := Lines;
  247.   If Y = 0 Then StartY := 11 - (DispLines div 2)
  248.   Else StartY := Y;
  249.   If DispWidth < Length(Title)+1 Then DispWidth := Length(Title)+1;
  250.   EndX := StartX+DispWidth+3; { With box ofcourse}
  251.   EndY := StartY + DispLines + 1;
  252.   StartP := 1; Endp := DispLines;
  253.   PrevHiTopic := 1;
  254.   HiTopic := 1;
  255.   If ResetSelection Then For Tmp := 1 To MaxLines do Selection[Tmp] := False;
  256.   SWidth := EndX-StartX-2;
  257.  End; { WITH }
  258. End; {SetParameters}
  259.  
  260. Procedure DisplayTopic(LN,X,Y,F,B,TopN : Byte); { Display a topic }
  261. Var Ch : Char;
  262.  CurrTopic : ShortString;
  263. Begin
  264.  CurrTopic := TopicToString(TopN);
  265.  ColorWrite(X,Y,F,B,CurrTopic + ReplicateChar(DispWidth-Length(CurrTopic),' '));
  266.  With Lists[LN]^ Do If Selection[TopN] Then Ch :=Chr(SelChar)
  267.  Else Ch := ' ';
  268.  ColorWriteChar(X-1,Y,F,B,Ch);
  269. End; { DisplayTopic }
  270.  
  271. Procedure DisplayVisibleLines(LNum,Start,Stop : Byte); { Refresh visible lines }
  272. Var Tmp : Byte;
  273. Begin
  274.  With Lists[LNum]^ Do
  275.  For Tmp := Start To Stop Do DisplayTopic(LNum,StartX+2,StartY+Tmp-Start+1,
  276.                                            InnerF,InnerB,Tmp);
  277. End; { DisplayVisibleLines }
  278.  
  279. Procedure SavePrevScreen(LN : Byte); { Save screen block under displayed list }
  280. Var BlockSize : Word;
  281. Begin
  282.  With Lists[LN]^ Do
  283.  Begin
  284.    If Shadow Then BlockSize := ((EndX-StartX+2) Shl 2) + ((EndY-StartY+1) * 160)
  285.    Else BlockSize := ((EndX-StartX) Shl 2) + ((EndY-StartY) * 160);
  286.    If MaxAvail < BlockSize Then VTListError(4);
  287.    GetMem(SavedScr,BlockSize);
  288.    If Shadow Then GetFromScreen(StartX-2,StartY,EndX,EndY+1,SavedScr)
  289.    Else GetFromScreen(StartX,StartY,EndX,EndY,SavedScr);
  290.  End; { WITH }
  291. End; {SavePrevScreen}
  292. Procedure RestorePrevScreen(LN : Byte); { Restore screen block under displayed list }
  293. Var BlockSize : Word;
  294. Begin
  295.  With Lists[LN]^ Do
  296.  Begin
  297.    If Shadow Then BlockSize := ((EndX-StartX+2) Shl 2) + ((EndY-StartY+1) * 160)
  298.    Else BlockSize := ((EndX-StartX) Shl 2) + ((EndY-StartY) * 160);
  299.    If Shadow Then PutToScreen(StartX-2,StartY,EndX,EndY+1,SavedScr)
  300.    Else PutToScreen(StartX,StartY,EndX,EndY,SavedScr);
  301.    FreeMem(SavedScr,BlockSize);
  302.  End; { WITH }
  303. End; {RestorePrevScreen}
  304.  
  305.  
  306. Procedure DrawList(LN : Byte); { Draw list box }
  307. Begin
  308.  With Lists[LN]^ Do
  309.  Begin
  310.     If Explode Then ExplodeBox(StartX,StartY,EndX,EndY,BoxF,BoxB,BoxT)
  311.     Else Begin
  312.           ClearText(StartX,StartY,EndX,EndY,BoxF,BoxB);
  313.           DrawBox(StartX,StartY,EndX,EndY,BoxT)
  314.          End;
  315.     If Shadow Then If (StartX > 3) And (EndY < 24) Then DisplayShadow(StartX,StartY,EndX,EndY);
  316.     ClearText(StartX+1,StartY+1,EndX-1,EndY-1,InnerF,InnerB);
  317.     ColorWriteBetween(StartX,EndX,StartY,TitF,TitB,Title);
  318.  End;
  319. End; {DrawList}
  320. Function HaveSelection (LN : Byte) : Boolean; { Search if user have allready }
  321. Var Tmp : Byte;                               { selected items }
  322. Begin
  323.  HaveSelection := False;
  324.  With Lists[Ln]^ Do For Tmp := 1 to ListLines Do If Selection[Tmp] Then Begin
  325.                                                                          HaveSelection := True;
  326.                                                                          Tmp := ListLines;
  327.                                                                         End;
  328. End;
  329. Procedure SetLineAttrib(X,X1,Y,F,B : Byte); { Set attributes of line }
  330. Var Tmp : Byte;
  331. Begin
  332.  For Tmp := X To X1 do SetCharAttr(Tmp,Y,Attrib(F,B));
  333. End; {SetLineAttrib}
  334. Procedure OperateList; { Here user move bar, select & etc. }
  335. Var Finish : Boolean;
  336.     Refresh_State : Boolean;
  337. Begin
  338.  Finish := False; Refresh_State := True;
  339.  With Lists[ListTable]^ Do
  340.  Repeat
  341.   If Refresh_State Then Begin { If topcs need to refresh}
  342.                           DisplayVisibleLines(ListTable,StartP,EndP);
  343.                           Refresh_State := False;
  344.                         End;
  345.  
  346.   If EndP < ListLines Then PlainWriteChar(EndX,EndY-1,#25)
  347.   Else PlainWriteChar(EndX,EndY-1,Box[Boxt].RightVLine); { If user is in }
  348.   If StartP > 1 Then PlainWriteChar(EndX,StartY+1,#24)  {beginnig or end of}
  349.   Else PlainWriteChar(EndX,StartY+1,Box[Boxt].RightVLine); {list - draw
  350.                                                            { the U/D arrow }
  351.   DisplayTopic(ListTable,StartX+2,StartY+PrevHiTopic, { Display previous }
  352.                InnerF,InnerB,StartP-1+PrevHiTopic);    {hilighted topic }
  353.   DisplayTopic(ListTable,StartX+2,StartY+HiTopic,     { Display current }
  354.                SelTopicF,SelTopicB,StartP-1+HiTopic); {hilighted topic }
  355.   SetLineAttrib(StartX+1,StartX+1+SWidth,StartY+PrevHiTopic,InnerF,InnerB);
  356.   SetLineAttrib(StartX+1,StartX+1+SWidth,StartY+HiTopic,SelTopicF,SelTopicB);
  357.   XY(StartX+1,StartY+HiTopic);
  358.   {hilight current and set previous to normal topic }
  359.   GetKey(RetLAChar,RetLPChar); { Wait user action }
  360.   Case RetLpChar of { Search user action in standart actions }
  361.  {ESC}   1 : If EscValid Then Finish := True
  362.              Else Clang;
  363.  
  364.  {UP}   72 : Begin
  365.               PrevHiTopic := HiTopic;
  366.               Dec(HiTopic);
  367.              End;
  368. {Down}  80 : Begin
  369.               PrevHiTopic := HiTopic;
  370.               Inc(HiTopic);
  371.              End;
  372. {PgUp}  73 : Begin
  373.               If StartP > DispLines+1 Then Begin
  374.                                            StartP := StartP - DispLines;
  375.                                            EndP := EndP - DispLines;
  376.                                           End
  377.                 Else Begin  { If list is in beginnig hilight 1`st topic }
  378.                       StartP := 1;
  379.                       EndP :=DispLines;
  380.                       PrevHiTopic := HiTopic;
  381.                       HiTopic := 1;
  382.                      End;
  383.                 Refresh_State := True;
  384.              End;
  385. {PgDn}  81 : Begin
  386.               Refresh_State := True;
  387.               If EndP < ListLines - DispLines Then Begin
  388.                                                     StartP := StartP + DispLines;
  389.                                                     EndP := EndP + DispLines;
  390.                                                    End
  391.                Else Begin { If list is in end hilight last topic }
  392.                       StartP := ListLines - DispLines+1;
  393.                       EndP := ListLines;
  394.                       PrevHiTopic := HiTopic;
  395.                       HiTopic := UserLines;
  396.                     End;
  397.              End;
  398. {Home}  71 : Begin
  399.               Refresh_State := True;
  400.               PrevHiTopic := HiTopic;
  401.               HiTopic := 1;
  402.               StartP := 1;
  403.               EndP := DispLines;
  404.              End;
  405. {End}   79: Begin
  406.               Refresh_State := True;
  407.               StartP := ListLines - DispLines+1;
  408.               EndP := ListLines;
  409.               PrevHiTopic := HiTopic;
  410.               HiTopic := UserLines;
  411.              End;
  412.   End; { CASE }
  413.  { ** Look if in selectchars ** }
  414.   If RetLPChar in SelChars Then Case Only1Selection of { If can select more }
  415.                                        False : Selection[StartP+HiTopic-1] := Not Selection[StartP+HiTopic-1];
  416.                                         True : Begin
  417.                                                 If Selection[StartP+HiTopic-1] Then Selection[StartP+HiTopic-1] := False
  418.                                                  Else If Not HaveSelection(ListTable) Then Selection[StartP+HiTopic-1] := True
  419.                                                       Else If Beep Then Clang;
  420.                                                End;
  421.                                 End;
  422.   { ** Look if in chars to finish ** }
  423.   If RetLPChar in EndChars Then Finish := True;
  424.   If HiTopic < 1 Then Begin { Can the bar moves up }
  425.                        HiTopic := 1;
  426.                        If StartP > 1 Then Begin { Is this a start of list }
  427.                                            Dec(StartP);
  428.                                            Dec(EndP);
  429.                                            Refresh_State := True;
  430.                                           End;
  431.                       End;
  432.   If HiTopic > DispLines Then Begin { Can the bar moves down }
  433.                                 HiTopic := DispLines;
  434.                                 If EndP < ListLines Then Begin { Is this a end of list }
  435.                                                           Inc(StartP);
  436.                                                           Inc(Endp);
  437.                                                           Refresh_State := True;
  438.                                                          End;
  439.                               End;
  440.    If Addr(CallHook) <> Nil Then { If user have a hook }
  441. { Yes! Call then user hook } Lists[ListTable]^.CallHook(RetLPChar,Refresh_State,StartP+HiTopic-1);
  442.  Until Finish;
  443.  LastHiTop := StartP+HiTopic-1;
  444. End; {OperateList}
  445.  
  446. Begin { DisplayList}
  447.  If ListLines > MaxLines Then VTListError(7); { If user is out of range }
  448.  If LInfo[ListTable].Displayed then VTListError(6);
  449.  If Not LInfo[ListTable].Attached then VTListError(1);
  450.  LInfo[ListTable].Displayed := True; { Set that this list is allready displayed }
  451.  GetXY(CX,CY); GetCursor(CT,CB);
  452.  SmallCursor;
  453.  SetParameters(ListTable); { Define Positions, lengths & etc. }
  454.  SavePrevScreen(ListTable); { Save screen block }
  455.  DrawList(ListTable);       { Draw box,shadows & etc. }
  456.  OperateList;               { Give control to user }
  457.  RestorePrevScreen(ListTable); { Restore screen block }
  458.  LInfo[ListTable].Displayed := False; { Disable displayed flag of list }
  459.  XY(CX,CY);
  460.  SetCursor(CT,CB);
  461. End; { DisplayList} { Return in user program }
  462. Procedure ListInit;
  463. Begin
  464.  For Tmp := 1 To MaxLists Do  With LInfo[Tmp] Do Begin
  465.                                                    Attached := False;
  466.                                                    Displayed := False;
  467.                                                   End;
  468.  
  469. End;
  470. BEGIN
  471. ListInit;
  472. END.